Shareware Grab Bag/Shareware Grab Bag.iso/011/reformat.arc/REFORMAT.PAS

Pascal/Delphi Source File | 1986-05-20 | 47KB | 1,380 lines

program reformat;
{
Program to reformat any disk attached to a Olivetti PC or compatible.
The program will probably work well on any MS/PC-DOS machine running under
DOS 2.xx.  Fixed disks of all sizes

**    Modified May 16, 1986 By Rick Watson
**
**          Original program did not know about long (16 bit) FAT's.
**          Therefore the program blew up with disks with over 4K
**          clusters.  Made changes necessary to accomodate disks
**          up to 16K clusters.
**
**          Also found that if the program is run on the default disk,
**          a directory displayed garbage upon completion and DOS could
**          not find any files.  This is because the program rearranged
**          the FAT's and directories without telling DOS.  DOS keeps
**          information in memory about the disk that no longer matches
**          reality.  This can cause a great deal of tension when the
**          user comes to the conclusion that his disk has been trashed.
**          I have changed the program to require the user to reboot
**          the system upon completion if it is run on the default drive.
**
**          I have tested this program with my 20 Meg hard
**          disk, a 2 Meg RAMdisk and 360K floppies.  All testing seems
**          to be successful, however...
**          Since this program rewrites the FAT's, directories,
**          sub-directories, and file data, it constitutes a risk.
**          An undetected program bug, power interruption during use,
**          a well directed cosmic ray, etc., etc., etc. could cause
**          total and irreversible loss of ALL data on the disk being
**          reformatted (The Norton Utilities will just laugh at you).
**
**                        USE AT YOUR OWN RISK!
**                       (being backed up helps)
**
Global types                                                           }

type

  Regpack    = record case integer of
               1: (ax, bx, cx, dx, bp, si, di, ds, es, flags : integer);
               2: (al, ah, bl, bh, cl, ch, dl, dh            : byte);
               end;

  Boot       = record
                 Jump:                  array[0..2] of byte;
                 OEM :                  array[0..7] of char;
                 SectorSize:            integer;
                 Clustersize:           byte;
                 ReservedSectors:       integer;
                 NumberOfFats:          byte;
                 RootDirSize,
                 TotalSectors:          integer;
                 MediaDescriptor:       byte;
                 FatSize,
                 TrackSize,
                 NumberOfHeads,
                 NumberOfHiddenSectors: integer;
               end;

  IntArray   = array[0..32766] of integer;

  Buffer     = array[0..32766] of byte;

  LongInteger      = array[0..1] of integer;

  DirectoryPointer = ^DirectoryEntry;

  DirectoryEntry   = record
                       EntryName:          array[0..10] of char;
                       Attribute:          byte;
                       Reserved:           array[1..10] of byte;
                       TimeLastUpdated:    integer;
                       DateLastUpdated:    integer;
                       StartingCluster:    integer;
                       Filesize:           LongInteger;
                       NewStartingCluster: integer;
                       Next,
                       SubDirectory:       DirectoryPointer;
                     end;

  WorkString       = string[255];

const

  ReadOnly:        byte = $01;
  HiddenFile:      byte = $02;
  SystemFile:      byte = $04;
  VolumeLabel:     byte = $08;
  Subdirectory:    byte = $10;
  Archive:         byte = $20;

  NeverUsed:       byte = $00;
  Erased:          byte = $E5;

  FixedDisk:       byte = $F8;
  Dual8Sector:     byte = $FF;
  Single8Sector:   byte = $FE;
  Dual9Sector:     byte = $FD;
  Single9Sector:   byte = $FC;

  Unused:               integer = $0000;

var

{ Drive characteristics and constants communications block             }

  DriveLetter:          char;
  NumberOfFats,
  Media,
  DefaultDrive,
  DriveNumber:          byte;
  FreeClusters,
  TotalDataClusters,
  FirstDataSector,
  FATsize,
  FirstFATsector,
  RootDirSize,
  DirectorySectors,
  FirstDirectorySector,
  SectorSize,
  ReservedMinimum,
  ReservedMaximum,
  BadCluster,
  LastMinimum,
  LastMaximum,
  LastNormal,
  ClusterSize:          integer;

{ Global variables                                                     }

  Registers:            Regpack;
  OldFATindex,
  NewFATindex,
  Errors,
  LostClusters,
  TotalFiles,
  HiddenFiles,
  InRootDirectory,
  InSubdirectories,
  NonContiguousFiles,
  Subdirectories,
  MovedClusters,
  ClustersToMove,
  Count:                integer;
  SAVEaddress,
  DTAddress:           ^Buffer;
  PermutationAddress,
  NewFATAddress,
  OldFATAddress:       ^IntArray;
  RootDir:              DirectoryPointer;
  MovedField,
  InputField,
  LogField,
  WarningField,
  ErrorField,
  DisasterField:        LongInteger;
  Anything,
  Instr:                char;
  BigFAT,
  NeedReboot,
  AlreadyWritten:       boolean;
  DiskLabel:            array[0..10] of char;

(* procedure Int25(var Registers: Regpack); external 'Int25.com'; *)

(* procedure Int26(var Registers: Regpack); external 'Int26.com'; *)

{$I REFORMAT.INC}

procedure Beep;

begin
   write(chr(7));
end;

procedure WriteLog(Text: WorkString);

var
  Count: integer;

begin
  gotoxy(LogField[0], LogField[1]);
  for Count := LogField[0] to 79 do write(' ');
  gotoxy(LogField[0], LogField[1]);
  write(Text);
end;

procedure WriteWarning(Text: WorkString);

var
  Count: integer;

begin
  gotoxy(WarningField[0], WarningField[1]);
  for Count := WarningField[0] to 79 do write(' ');
  gotoxy(WarningField[0], WarningField[1]);
  write(Text);
end;

procedure WriteError(Text: WorkString);

var
  Count: integer;

begin
  gotoxy(ErrorField[0], ErrorField[1]);
  for Count := ErrorField[0] to 79 do write(' ');
  gotoxy(ErrorField[0], ErrorField[1]);
  write(Text);
end;

procedure WriteDisaster(Text: WorkString);

var
  Count: integer;

begin
  gotoxy(DisasterField[0], DisasterField[1]);
  for Count := DisasterField[0] to 79 do write(' ');
  gotoxy(DisasterField[0], DisasterField[1]);
  write(Text);
end;

procedure GetInput(var Instr: char);

var
  Count: integer;

begin
  gotoxy(InputField[0], InputField[1]);
  for Count := InputField[0] to 79 do write(' ');
  gotoxy(InputField[0], InputField[1]);
  Beep;
  readln(Instr);
end;

procedure GetInformation;

{ Ask DOS for information about the specified or default disk.
  If we have an error return code from DOS we assume that the disk
  specified was invalid. }

var

  ValidDrive:  boolean;
  InLetter:    char;
  Instr:       char;
  x:           integer;

begin
{ get current disk: MS-DOS function call 19h
  information is returned in AL: 0 = A, 1 = B, etc                     }
  WriteLog('Reading Disk Information');
  Registers.ah := $19;
  msdos(Registers);
  DefaultDrive := Registers.al;
  if paramcount = 0
  then
     Instr   := chr(65 + DefaultDrive)
  else
     Instr   := copy(paramstr(1), 1, 1);
  ValidDrive   := false;
  BigFAT       := false;
  with Registers do repeat
       if ord(Instr) < 64 then Instr := chr($FF);
       DriveLetter := upcase(Instr);
       DriveNumber := ord(DriveLetter) - 64;
       ah := $36;
       dl := DriveNumber;
       msdos(Registers);
       if ax <> $ffff
       then begin
            DriveNumber          := DriveNumber - 1;
            FreeClusters         := bx;
            TotalDataClusters    := dx;
            if TotalDataClusters > 4095 then BigFAT := true;
            Sectorsize           := cx;
            ClusterSize          := ax;
            FirstFATsector       := 1;
            if BigFAT then
               begin
               x                  := TotalDataClusters - 4096;
               Count              := (( x + 2 ) * 4 );
               end
            else
               Count              := (( TotalDataClusters + 2 ) * 3 );
            If Count mod ( SectorSize * 2 ) = 0
            then FATsize         := Count div ( SectorSize * 2 )
            else FATsize         := Count div ( SectorSize * 2 ) + 1;
            If BigFAT then FATsize := FATsize + (4096 div (SectorSize div 2));
            FirstDirectorySector := 2 * FATsize + 1;
            ValidDrive           := true;
            if BigFAT then
                 begin
                 ReservedMinimum      := $7FF0;
                 ReservedMaximum      := $7FF6;
                 BadCluster           := $7FF7;
                 LastMinimum          := $7FF8;
                 LastMaximum          := $7FFF;
                 LastNormal           := $7FFF;
                 end
            else
                 begin
                 ReservedMinimum      := $0FF0;
                 ReservedMaximum      := $0FF6;
                 BadCluster           := $0FF7;
                 LastMinimum          := $0FF8;
                 LastMaximum          := $0FFF;
                 LastNormal           := $0FFF;
                 end;
       end
       else begin
            WriteWarning('Invalid driveletter, enter new letter!');
            GetInput(Instr);
            WriteWarning(' ');
       end;
  until ValidDrive;
  if DriveNumber = DefaultDrive then
     NeedReboot := true
  else
     NeedReboot := false;
end;

function CarryFlag: boolean;

begin
  CarryFlag := ( Registers.Flags and $01 ) <> 0 ;
end;

procedure ResetDisk;

begin
  Registers.ah := $0D;
  msdos(Registers);
end;

procedure ReadSectors(SectorNumber, NumberOfSectors: integer);

begin
  with Registers do repeat
       al := DriveNumber;
       cx := NumberOfSectors;
       dx := SectorNumber;
       ds := seg(DTAddress^);
       bx := ofs(DTAddress^);
       int2526($25);
       if CarryFlag then begin
            if not AlreadyWritten
            then begin
                 WriteWarning('No data lost!');
                 WriteError('Disk read error, enter A (abort), R (retry)?');
            end
            else begin
                 WriteError('Probably loss of data!');
                 WriteDisaster('Disk read error A(bort), R(etry), I(gnore)?');
            end;
            Instr := '?';
            repeat
                 Getinput(Instr);
            until ( Instr in ['a', 'A', 'r', 'R'] )
              or (( Instr in ['i', 'I'] ) and AlreadyWritten );
            if Instr in ['a', 'A']
            then begin
                 clrscr;
                 halt;
            end
            else begin
                 WriteError(' ');
                 WriteWarning(' ');
                 WriteDisaster(' ');
                 if Instr in ['i', 'I'] then flags := 0;
       end; end;
  until not CarryFlag;
end;

procedure WriteSectors(SectorNumber, NumberOfSectors: integer);

begin
  with Registers do repeat
       al := DriveNumber;
       cx := NumberOfSectors;
       dx := SectorNumber;
       ds := seg(DTAddress^);
       bx := ofs(DTAddress^);
       int2526($26);
       if CarryFlag
       then begin
            if not AlreadyWritten
            then begin
                 WriteWarning('No data lost!');
                 WriteError('Disk write error, enter A (abort), R (retry)?');
            end
            else begin
                 WriteError('Probably data lost!');
                 WriteDisaster('Disk write error A(bort), R(etry), I(gnore)?');
            end;
            repeat
                 Getinput(Instr);
            until ( Instr in ['a', 'A', 'r', 'R'] )
              or (( Instr in ['i', 'I'] ) and AlreadyWritten );
            if Instr in ['a', 'A']
            then begin
                 clrscr;
                 halt;
            end
            else begin
                 WriteError(' ');
                 WriteWarning(' ');
                 WriteDisaster(' ');
                 if Instr in ['i', 'I'] then flags := 0;
       end; end;
  until not CarryFlag;
  AlreadyWritten := true;
end;

procedure ReadCluster(ClusterNumber: integer);

var
  SectorNumber: integer;

begin
{ To get around Turbo's maxint, (in case of fixed disks of 20 MB the largest
  sectornumber is greater than 32767) we split the following formula:

     SectorNumber := ClusterSize * ( ClusterNumber - 2 ) + FirstDataSector;

  Multiplication does not return a correct value when Sectornumber becomes
  greater than maxint. Addition returns a word value (16 bits) that is the
  correct sectornumber if interpreted as a non-signed integer.
  Since ClusterSize is ALWAYS (PC-DOS TECH REF: chap Device Drivers,
  boot record layout) a power of 2, we may divide it by 2. }

     if ClusterSize < 2
     then SectorNumber := ClusterNumber - 2 + FirstDataSector
     else SectorNumber := ( ClusterSize div 2 ) * ( ClusterNumber - 2 ) +
                          ( ClusterSize div 2 ) * ( ClusterNumber - 2 ) +
                          FirstDataSector;
     ReadSectors(SectorNumber, ClusterSize);
end;

procedure WriteCluster(ClusterNumber: integer);

var
  SectorNumber: integer;

begin
{ To get around Turbo's maxint, (in case of fixed disks of 20 MB the largest
  sectornumber is greater than 32767) we split the following formula:

     SectorNumber := ClusterSize * ( ClusterNumber - 2 ) + FirstDataSector;

  Multiplication does not return a correct value when Sectornumber becomes
  greater than maxint. Addition returns a word value (16 bits) that is the
  correct sectornumber if interpreted as a non-signed integer.
  Since ClusterSize is ALWAYS (PC-DOS TECH REF: chap Device Drivers,
  boot record layout) a power of 2, we may divide it by 2. }

     if ClusterSize < 2
     then SectorNumber := ClusterNumber - 2 + FirstDataSector
     else SectorNumber := ( ClusterSize div 2 ) * ( ClusterNumber - 2 ) +
                          ( ClusterSize div 2 ) * ( ClusterNumber - 2 ) +
                          FirstDataSector;
     WriteSectors(SectorNumber, ClusterSize);
end;

procedure ReadBootSector(var DTArea: Buffer);

{ Read the bootsector from disk. Use the information we find in it
  to set a number of variables in the communication block. If the
  information in the bootsector is inconsistent with the story DOS
  told us (GetInformation) we use the FAT identification byte for
  the setting of the variables. This will probably only occur in
  case we have a disk that was formatted under a pre DOS 2.0 version.}

var
  FATidentification: byte;
  Instr:             char;
  BootInfo:          Boot absolute DTArea;

begin
  WriteLog('Reading Bootsector.');
  ReadSectors(0, 1);
  if        ( TotalDataClusters        >= 16284 )
      or    ( TotalDataClusters        <  0     )
  then begin
     WriteWarning('Disk contains too many clusters for program.');
     WriteError('Program limit is 16283 clusters.');
     WriteDisaster('Press enter to return to DOS.');
     GetInput(Instr);
     clrscr;
     halt;
     end;
  if        ( BootInfo.SectorSize      <> SectorSize )
     or     ( BootInfo.ClusterSize     <> Clustersize )
     or     ( BootInfo.NumberOfFats    =  0 )
     or     ( BootInfo.RootDirSize     =  0 )
     or     ( BootInfo.TotalSectors    <  TotalDataClusters * ClusterSize )
     or not ( BootInfo.MediaDescriptor in [$F0..$FF] )
     or     ( BootInfo.FATsize         <> FATsize )
  then begin
     WriteWarning('Pre DOS 2.0 formatted disk, or incomplete bootsector.');
     ReadSectors(FirstFATsector, 1);
     FATidentification := DTArea[0];
     NumberOfFATs      := 2;
     if ( FATidentification = Single8Sector )
     or ( FATidentification = Single9Sector )
     then RootDirSize  := 64
     { Not Single Sided }
     else if ( FATidentification = Dual8Sector )
          or ( FATidentification = Dual9Sector )
          then RootDirSize  := 112
          else if FATidentification = FixedDisk
               { Fixed Disk }
               then begin
                    WriteError('Fixed Disk: cannot compute size.');
                    WriteDisaster('Press enter to return to DOS.');
                    GetInput(Instr);
                    clrscr;
                    halt;
               end
               else begin
                    WriteError('Unknown Disk Type (FAT id byte).');
                    WriteDisaster('Press enter to return to DOS.');
                    GetInput(Instr);
                    clrscr;
                    halt;
               end;
     FirstDataSector   := NumberOfFats * Fatsize +
                          RootDirSize  * 32 div SectorSize + 1;
     Media             := FATidentification;

  end
  else begin
       NumberOfFats    := BootInfo.NumberOfFats;
       if NumberOfFats <> 2
       then FirstDirectorySector := FATsize * NumberOfFats + 1;
       RootDirSize     := BootInfo.RootDirSize;
       FirstDataSector := NumberOfFats * Fatsize +
                          RootDirSize  * 32 div SectorSize + 1;
       Media           := BootInfo.MediaDescriptor;
  end;
end;

procedure ReadFat(var UnscrambledFAT: IntArray; var ScrambledFAT: Buffer);

{ Read and unscramble the FAT. Only the first FAT is processed.}

var
  i, Temp:     integer;

begin
  WriteLog('Reading and unscrambling FAT.');
  ReadSectors(FirstFATsector, FATsize);
  for i := 0 to TotalDataClusters + 1 do begin
      if BigFAT then
           begin
           move( ScrambledFAT[i * 2], Temp, 2);
           temp := temp and $7FFF;
           unscrambledFAT[i] := Temp;
           end
      else
           begin
           move( ScrambledFAT[3 * i div 2], Temp, 2);
           if odd(i) then Temp := Temp shr 4 else Temp := Temp and $0FFF;
           UnscrambledFAT[i] := Temp;
           end;
  end;
end;

procedure WriteFat(var UnscrambledFAT: IntArray; var ScrambledFAT: Buffer);

{ Write the FAT back to the disk. The FAT has to be scrambled before
  writing. FAT entries on disk are 12 bits long. Because there are mostly
  2 versions of the fat on disk, we write both fats simultaneously.}

var
  i,
  Temp1,
  Temp2:          integer;

begin
  WriteLog('Writing FAT.');
  for i := 0 to TotalDataClusters + 1 do begin
      if BigFAT then
           begin
           Temp1 := UnscrambledFAT[i];
           if (Temp1 and $4000) <> 0 then Temp1 := Temp1 or $8000;
           move( Temp1, ScrambledFAT[i * 2], 2);
           end
      else
           begin
           Temp1 := UnscrambledFAT[i];
           move( ScrambledFAT[3 * i div 2], Temp2, 2);
           if odd(i) then Temp1 := (Temp2 and $000F) or (Temp1 shl 4)
                else Temp1 := (Temp2 and $F000) or Temp1;
           move( Temp1, ScrambledFAT[3 * i div 2], 2);
           end;
  end;
  WriteSectors(FirstFATsector, FATsize);
  WriteSectors(FirstFATsector + FATsize, FATsize);
end;

procedure ReadSubdirectory(var DTArea:      Buffer;
                           var FATarea:     INTArray;
                           var SubRoot:     DirectoryPointer;
                           StartingCluster: integer);

{ Link subdirectory entries in a list. Build a tree (by calling this
  routine recursively) if a subdirectory is found.}

var
  ClusterNumber,
  DirIndex:      integer;
  Present:       DirectoryPointer;
  EndSearch:     boolean;

begin
  Subdirectories := Subdirectories + 1;
  ClusterNumber  := StartingCluster;
  SubRoot        := nil;
  EndSearch      := false;
  repeat
       ReadCluster(ClusterNumber);
       DirIndex     := 0;
       repeat
            if not ( DTArea[DirIndex] in [NeverUsed, Erased] )
            then begin
                 if SubRoot = nil
                 then begin
                      new(SubRoot);
                      Present := SubRoot;
                 end
                 else begin
                      new(Present^.Next);
                      Present := Present^.Next;
                 end;
                 move(DTArea[DirIndex], Present^, 32);
                 if ( Present^.Attribute = Subdirectory ) and
                    ( Present^.EntryName[0] <> '.' )
                 then begin
                      ReadSubdirectory(DTArea, FATarea, Present^.SubDirectory,
                                       Present^.StartingCluster);
                      Readcluster(ClusterNumber);
                 end
                 else begin
                      Present^.SubDirectory := nil;
                      if Present^.Entryname[0] <> '.'
                      then begin
                           TotalFiles            := TotalFiles + 1;
                           InSubdirectories      := InSubdirectories + 1;
                           if ( Present^.Attribute and HiddenFile ) <> 0
                           then HiddenFiles := HiddenFiles + 1;
            end; end; end
            else if DTArea[DirIndex] = NeverUsed
            then EndSearch := true;
            DirIndex := DirIndex + 32;
       until    ( DirIndex >= SectorSize * ClusterSize)
             or (  EndSearch                          );
       ClusterNumber :=  FATarea[ClusterNumber];
  until ( ClusterNumber >= ReservedMinimum ) or EndSearch;
  if Present <> nil then Present^.Next := nil;
end;

procedure ReadDirectories(var DTArea: Buffer);

{ Read the Rootdirectory and whenever an entry for a subdirectory is
  found call ReadSubdirectory. Link all directory entries dynamically
  in a linked list. This list is actually a tree, because the lists
  for subdirectories are linked to this list.}

var
  EndSearch:     boolean;
  SectorNumber,
  DirIndex:      integer;
  Present:       DirectoryPointer;

begin
  WriteLog('Reading Directory and Subdirectories.');
  SectorNumber := FirstDirectorySector;
  RootDir      := nil;
  EndSearch    := false;
  repeat
       DirIndex := 0;
       ReadSectors(SectorNumber, 1);
       repeat
            if not ( DTArea[DirIndex] in [NeverUsed, Erased] )
            then begin
                 if RootDir = nil
                 then begin
                      new(RootDir);
                      Present := RootDir;
                 end
                 else begin
                      new(Present^.Next);
                      Present := Present^.Next;
                 end;
                 move(DTArea[DirIndex], Present^, 32);
                 if ( Present^.Attribute = Subdirectory ) and
                    ( Present^.EntryName[0] <> '.' )
                 then begin
                      ReadSubdirectory(DTArea, OldFATaddress^,
                                       Present^.SubDirectory,
                                       Present^.StartingCluster);
                      ReadSectors(SectorNumber, 1);
                 end
                 else begin
                      Present^.SubDirectory := nil;
                      if ( Present^.Attribute    <> VolumeLabel ) and
                         ( Present^.Entryname[0] <> '.'         )
                      then begin
                           TotalFiles            := TotalFiles + 1;
                           InRootDirectory       := InRootDirectory + 1;
                           if ( Present^.Attribute and HiddenFile ) <> 0
                           then HiddenFiles := HiddenFiles + 1;
            end; end; end
            else if DTArea[DirIndex] = NeverUsed
            then EndSearch := true;
            DirIndex := DirIndex + 32;
        until ( DirIndex >= SectorSize ) or EndSearch;
        SectorNumber := SectorNumber + 1;
   until ( SectorNumber = FirstDataSector ) or EndSearch;
   if Present <> nil then Present^.Next := nil;
end;

procedure RemakeFAT(var OldFATarea, NewFATarea, Permutation: IntArray;
                    Root: DirectoryPointer; Parent, ThisDir: integer);

{ This procedure is called recursively.
  From the OldFAT and the directory entries we construct a NewFAT and
  a Permutation. The Permutation is used by DoIt for moving the
  clusters. This routine is called one extra time for the chain of
  the empty clusters by LinkFreeDataClusters.
  Recursion is used whenever we find an entry for a subdirectory, in
  the following way: first call this routine for the remainder of the
  current directory, second for the subdirectory.
  The function NewFATindex is used to prevent accidental use of clusters
  that were marked as bad or reserved clusters.}

function NextFATindex: integer;

var
  Temp: integer;

begin
     Temp := NewFATindex + 1;
     while ( OldFATarea[Temp] >= ReservedMinimum ) and
           ( OldFATarea[Temp] <= BadCluster      ) and
           ( Temp <= TotalDataClusters + 1       )
     do begin
          NewFATarea[Temp] := OldFATarea[Temp];
          Temp             := Temp + 1;
     end;
     NextFATindex := Temp;
end;

var
  Present: DirectoryPointer;
  Split:   boolean;
  Temp:    integer;

begin
  if NewFATindex = 1 then NewFATindex := NextFatindex;
  Present := Root;
  Split   := false;
  while ( Present <> nil ) and not Split do begin
       if ( Present^.Attribute <> VolumeLabel ) and
          ( Present^.StartingCluster <> 0 ) and
          ( Present^.Entryname[0] <> '.')
       then begin
            if Present^.SubDirectory <> nil
            then begin
                 Split := true;
                 RemakeFAT(OldFATarea, NewFATarea, Permutation,
                           Present^.Next, Parent, ThisDir);
            end;
            OldFATindex                 := Present^.StartingCluster;
            Present^.NewStartingCluster := NewFatindex;
            Permutation[NewFATindex]    := OldFATindex;
            while OldFATarea[OldFATindex] < LastMinimum do begin
                  Temp                     := NextFatindex;
                  NewFATarea[NewFATindex]  := Temp;
                  NewFatindex              := Temp;
                  OldFATindex              := OldFATarea[OldFATindex];
                  Permutation[NewFATindex] := OldFATindex;
            end;
            NewFatArea[NewFATindex] := LastNormal;
            NewFATindex             := NextFatindex;
            if Split then
            RemakeFAT(OldFATarea, NewFATarea, Permutation,
                      Present^.SubDirectory, ThisDir,
                      Present^.NewStartingCluster);
       end
       else begin
            if ( Present^.EntryName[0] = '.'  ) and
               ( Present^.EntryName[1] = '.'  )
            then Present^.NewStartingCluster := Parent
            else if Present^.EntryName[0] = '.'
                 then Present^.NewStartingCluster := ThisDir
                 else begin
                      Present^.NewStartingCluster := 0;
                      if Present^.Attribute = VolumeLabel
                      then for Count := 0 to 10 do
                           DiskLabel[Count] := Present^.EntryName[Count];
       end;      end;
       Present := Present^.Next;
  end;
end;

procedure LinkFreeClusters(var OldFATarea, NewFATarea: IntArray);

{ Link Free clusters in a chain, pointed to by Empty^.
  Use RemakeFAT to fill Permutation, but clean NewFAT after
  this. This procedure will ensure that permutation is a
  proper permutation, without double entries which might
  cause DoIt to loop indefinitely or destroy our disk. }

var
  Count,
  Next,
  Previous: integer;
  Empty:    DirectoryPointer;

begin
  new(Empty);
  Empty^.Next            := nil;
  Empty^.SubDirectory    := nil;
  Empty^.Entryname[0]    := 'X';
  Empty^.Attribute       := HiddenFile;
  Empty^.StartingCluster := 0;
  Count                  := 2;
  while ( Count <= TotalDataClusters + 1 ) and
        ( OldFATarea[Count] <> 0         )
  do Count := Count + 1;
  if Count <= TotalDataClusters + 1
  then begin
       Empty^.StartingCluster := Count;
       Previous               := Count;
       while Count < TotalDataClusters + 1
       do begin
            Count := Count + 1;
            if OldFATarea[Count] = 0
            then begin
                 OldFATarea[Previous] := Count;
                 Previous             := Count;
       end; end;
       OldFATarea[Previous] := LastNormal;
  end;
  if Empty^.StartingCluster <> 0
  then begin
       RemakeFAT(OldFATarea, NewFATarea,
                 PermutationAddress^, Empty, 0, 0);
       Next := Empty^.NewStartingCluster;
       while Next <> LastNormal
       do begin
            Previous             := Next;
            Next                 := NewFATarea[Previous];
            NewFatarea[Previous] := 0;
  end; end;
end;

procedure  WriteSubdirectory(var DTArea: Buffer; var OldFATarea: IntArray;
                             Root: DirectoryPointer; Start: integer);

{ Write subdirectories back to disk. Erased entries are removed
  from the subdirectories. The subdirectories are written to their
  old locations, because DoIt will take care of moving the clusters
  to their new places. No effort is done to truncate a subdirectory
  which would be longer than needed after removal of erased entries.
  We will however set all remaining entries to 'NeverUsed'.
  This routine is used recursively.}

var
  Start1,
  ClusterNumber,
  DirIndex:      integer;
  Present:       DirectoryPointer;

begin
  Present       := Root;
  ClusterNumber := Start;
  while Present <> nil
  do begin
       DirIndex := 0;
       fillchar(DTArea, ClusterSize * SectorSize, $00);
       repeat
            Start1 := Present^.StartingCluster;
            Present^.StartingCluster := Present^.NewStartingCluster;
            move(Present^, DTArea[DirIndex], 32);
            if ( Present^.Attribute = SubDirectory ) and
               ( Present^.EntryName[0] <> '.' )
            then begin
                 WriteCluster(ClusterNumber);
                 WriteSubdirectory(DTArea, OldFATarea,
                                   Present^.SubDirectory, Start1);
                 ReadCluster(ClusterNumber);
            end;
            Present  := Present^.Next;
            DirIndex := DirIndex + 32;
       until ( DirIndex >= ClusterSize * SectorSize ) or ( Present = nil );
       WriteCluster(ClusterNumber);
       ClusterNumber := OldFATarea[ClusterNumber];
  end;
  if ClusterNumber < LastMinimum
  then begin
       fillchar(DTArea, SectorSize * ClusterSize, $00);
       while ClusterNumber < LastMinimum
       do begin
            WriteCluster(ClusterNumber);
            ClusterNumber := OldFATarea[ClusterNumber];
  end; end;
end;

procedure WriteDirectories(var DTArea: Buffer);

{ Write rootdirectory back to disk. Erased entries are removed
  from the directory. When we find a subdirectory entry, we first
  process this subdirectory by calling WriteSubdirectories,
  before we proceed with the root. All entries that are no in use
  are set to 'NeverUsed'.}

var
  Start,
  SectorNumber,
  DirIndex:      integer;
  Present:       DirectoryPointer;

begin
  WriteLog('Writing new Directory and Subdirectories.');
  SectorNumber := FirstDirectorySector;
  Present      := RootDir;
  while Present <> nil
  do begin
       DirIndex := 0;
       fillchar(DTArea, SectorSize, $00);
       repeat
            Start := Present^.StartingCluster;
            Present^.StartingCluster := Present^.NewStartingCluster;
            move(Present^, DTArea[DirIndex], 32);
            if ( Present^.Attribute = SubDirectory ) and
               ( Present^.EntryName[0] <> '.' )
            then begin
                 WriteSectors(SectorNumber, 1);
                 WriteSubdirectory(DTArea, OldFATaddress^,
                                   Present^.SubDirectory, Start);
                 ReadSectors(SectorNumber, 1);
            end;
            Present  := Present^.Next;
            DirIndex := DirIndex + 32;
       until ( DirIndex >= SectorSize ) or ( Present = nil );
       WriteSectors(SectorNumber, 1);
       SectorNumber := SectorNumber + 1;
  end;
  if SectorNumber < FirstDataSector
  then begin
       fillchar(DTArea, SectorSize, $00);
       while SectorNumber < FirstDataSector
       do begin
            WriteSectors(SectorNumber, 1);
            SectorNumber := SectorNumber + 1;
  end; end;
end;

procedure DoIt(var Permutation: IntArray; var DTArea, SaveArea: Buffer);

{ DoIt. This routine performs the actual reformating of the disk.
  The array Permutation contains in every location  [i] (starting
  from 2) which cluster has to be moved to cluster location i.
  Because we have a real permutation, this permutation can be
  parsed into a number of cyclical permutations. We start at the
  first cyclic permutation that is not identity. We save the first
  cluster of this cyclical permutation, proceed through the cyclical
  permutation, moving one cluster at a time, until we finish the
  cycle. We than write the saved cluster to disk.}

var
  Prior,
  Next,
  LastStart: integer;

begin

  WriteLog('Reformatting......');
  LastStart := 2;
  while LastStart <= TotalDataClusters + 1
  do begin
       if LastStart = Permutation[LastStart]
       then LastStart := LastStart + 1
       else begin
            ReadCluster(LastStart);
            move(DTArea, SaveArea, SectorSize * ClusterSize);
            Prior := LastStart;
            Next  := Permutation[LastStart];
            repeat
                 ReadCluster(Next);
                 WriteCluster(Prior);
                 MovedClusters      := MovedClusters + 1;
                 gotoxy(MovedField[0], MovedField[1]);
                 write(MovedClusters:10);
                 Permutation[Prior] := Prior;
                 Prior              := Next;
                 Next               := Permutation[Next];
            until Next = LastStart;
            move(SaveArea, DTArea, SectorSize * ClusterSize);
            WriteCluster(Prior);
            MovedClusters      := MovedClusters + 1;
            gotoxy(MovedField[0], MovedField[1]);
            write(MovedClusters:10);
            Permutation[Prior] := Prior;
  end; end;
  WriteLog(' ');
end;

procedure InitScreen;

var
  Row,
  Column: integer;
begin
  normvideo;
  clrscr;
  Row := 2;
  write(char(201)); for Column := 2 to 79 do write(char(205));
  write(char(187));
  write(char(186)); gotoxy(80, Row);
  write(char(186));
  gotoxy(15, Row); write('REFORMAT: an original JOS disk tool. Ver: 1.21(mod)');
  Row := Row + 1; gotoxy(1, Row);
  write(char(199)); for Column := 2 to 79 do write(char(196));
  write(char(182));
  for Row := 4 to 15 do
  begin
  write(char(186)); gotoxy(80, Row);
  write(char(186));
  end;
  write(char(199)); for Column := 2 to 79 do write(char(196));
  write(char(182));
  write(char(186)); gotoxy(80, 17);
  write(char(186));
  write(char(199)); for Column := 2 to 79 do write(char(196));
  write(char(182));
  for Row := 19 to 23 do
  begin
  write(char(186)); gotoxy(80, Row);
  write(char(186));
  end;
  write(char(200)); for Column := 2 to 79 do write(char(205));
  write(char(188));
  gotoxy(05, 19); write('User Input Field :');
  gotoxy(05, 20); write('Activity Logging :');
  gotoxy(05, 21); write('Warning  Messages:');
  gotoxy(05, 22); write('Error    Messages:');
  gotoxy(05, 23); write('Disaster Messages:');
  InputField[0]    := 24;
  InputField[1]    := 19;
  LogField[0]      := 24;
  LogField[1]      := 20;
  WarningField[0]  := 24;
  WarningField[1]  := 21;
  ErrorField[0]    := 24;
  ErrorField[1]    := 22;
  DisasterField[0] := 24;
  DisasterField[1] := 23;
end;

procedure CheckSubdirectory(var FAT: IntArray;
                            Root: DirectoryPointer; Parent, ThisDir: integer);

{ This procedure is called recursively.
  The SubDirectories are checked here. No attempt is made
  to correct any errors found. If any errors are found, a message
  is issued and the program stops. The users must first run CHKDSK from
  DOS before we accept the disk.                                        }

var
  Present: DirectoryPointer;
  Prior,
  Next:    integer;

begin
  Present := Root;
  while ( Present <> nil ) and ( Errors = 0 ) begin
       if ( Present^.Attribute <> VolumeLabel ) and
          ( Present^.StartingCluster <> 0 ) and
          ( Present^.Entryname[0] <> '.')
       then begin
            Next  := Present^.StartingCluster;
            Count := 0;
            repeat;
                 if ( Next > TotalDataClusters + 1 )
                 or ( Next < 1                     )
                 then begin
                      Errors := Errors + 1;
                      end
                 else begin
                      Prior      := Next;
                      Next       := FAT[Prior];
                      FAT[Prior] := 0;
                      if Next <> Prior + 1 then Count := Count + 1;
                 end;
            until ( Next >= LastMinimum ) or ( Errors <> 0 );
            if Count > 1 then NonContiguousFiles := NonContiguousFiles + 1;
            if Present^.SubDirectory <> nil
            then CheckSubdirectory(FAT, Present^.SubDirectory,
                                   ThisDir, Present^.StartingCluster);
       end
       else begin
            if ( Present^.EntryName[0] = '.' ) and
               ( Present^.EntryName[1] = '.' )
            then if Present^.StartingCluster <> Parent
                 then Errors := Errors + 1
                 else
            else if Present^.EntryName[0] = '.'
                 then if Present^.StartingCluster <> ThisDir
                      then Errors := Errors + 1
                      else
                 else if Present^.StartingCluster <> 0
                      then Errors := Errors + 1;
       end;
       Present := Present^.Next;
  end;
end;

procedure CheckDisk(var FAT: IntArray; Root: DirectoryPointer);

{ The FAT and the Directories are checked here. No attempt is made
  to correct any errors found. If any errors are found, a message
  is issued and the program stops. The users must first run CHKDSK from
  DOS before we accept the disk.                                        }

begin
  WriteLog('Checking FAT....');
  CheckSubdirectory(FAT, Root, 0, 0);
  for Count := 2 to TotalDataClusters + 1 do
       if ( FAT[Count] <> 0 ) and
          ( ( FAT[Count] < ReservedMinimum ) or
            ( FAT[Count] > BadCluster      ) )
       then LostClusters := LostClusters + 1;
  if Errors <> 0
  then begin
       WriteError('Crosslinked clusters found. Run CHKDSK first.');
       WriteWarning('Press Enter to return to DOS.');
       GetInput(Instr);
       clrscr;
       halt;
  end
  else if LostClusters <> 0
  then begin
       WriteError('Lost clusters found. Run CHKDSK first.');
       WriteWarning('Press Enter to return to DOS.');
       GetInput(Instr);
       clrscr;
       halt;
  end;
end;

procedure CountClustersToMove(var Permutation: IntArray);

begin
  for Count := 2 to TotalDataClusters + 1
  do if Permutation[Count] <> Count then ClustersToMove := ClustersToMove + 1;
end;

procedure InitCounters;

begin
  OldFATindex         := 0;
  NewFATindex         := 1;
  Errors              := 0;
  LostClusters        := 0;
  TotalFiles          := 0;
  HiddenFiles         := 0;
  InRootDirectory     := 0;
  InSubdirectories    := 0;
  NonContiguousFiles  := 0;
  Subdirectories      := 0;
  MovedClusters       := 0;
  ClustersToMove      := 0;
  Count               := 0;
  AlreadyWritten      := false;
  DiskLabel           := '           ';
end;

procedure WriteStatistics;

var
  Row: integer;

begin
  if NonContiguousFiles = 0 then ClustersToMove := 0;
  Row := 5;
  if DiskLabel <> '           '
  then begin
       gotoxy(18, Row); write('Volume Label is . . . . . :   ', DiskLabel);
       Row := Row + 1;
  end;
  gotoxy(18, Row); write(     'Total # of files. . . . . :', TotalFiles:10);
  if HiddenFiles <> 0
  then             write(' (hidden:', HiddenFiles:3,')');
  Row := Row + 1;
  if Subdirectories = 0
  then begin
       gotoxy(18, Row); write('All files in Rootdirectory.');
  end
  else begin
       gotoxy(18, Row); write('  in Root directory . . . :',
                                 InRootDirectory:10);
       Row := Row + 1;
       gotoxy(18, Row); write('  in ', Subdirectories:3, ' Subdirectories . :',
                                 InSubDirectories:10);
  end;
  Row := Row + 1;
  gotoxy(18, Row);      write('# of noncontiguous files. :',
                               NonContiguousFiles:10);
  Row := Row + 1;
  gotoxy(18, Row);      write('# of clusters to be moved :',
                               ClustersToMove:10);
  Row := Row + 1;
  gotoxy(18, Row);      write('# of clusters moved . . . :',
                               MovedClusters:10);
  MovedField[0] := 45;
  MovedField[1] := Row;
  Row := Row + 2;
  gotoxy(05, Row);      write('Clustersize . . :', ClusterSize:06,
                              ' sectors.');
  gotoxy(45, Row);      write('Sectorsize. . . :', SectorSize:06,
                              ' bytes.');
  Row := Row + 1;
  gotoxy(05, Row);      write('Total data space:', TotalDataClusters:6,
                              ' clusters.');
  gotoxy(45, Row);      write('DOS space . . . :', FirstDataSector:6,
                              ' sectors.');
  Row := Row + 1;
  gotoxy(05, Row);      write('Free data space :', FreeClusters:6,
                              ' clusters.');
  gotoxy(45, Row);      write('Disk type . . . :');
  case Media of
       $F8:   { FixedDisk    }   write(' Fixed Disk');
       $FE:   { Single8Sector}   write(' 1 sided / 8 sect');
       $FF:   { Dual8Sector  }   write(' 2 sided / 8 sect');
       $FC:   { Single9sector}   write(' 1 sided / 9 sect');
       $FD:   { Dual9sector  }   write(' 2 sided / 9 sect');
  end;
end;

procedure WriteDoc;

begin
  clrscr;
  writeln;
  writeln('           REFORMAT: an original JOS disk tool.');
  writeln;
  writeln('                Public Domain Software.');
  writeln;
  writeln('Makes all files  on a floppy or  fixed disk contiguous  again,');
  writeln('improving  disk  performance  dramatically. Either fixed disks');
  writeln('or diskettes.                               Requires DOS 2.xx.');
  writeln('Register at the following address to be on my mailing list for');
  writeln('updates:');
  writeln;
  writeln('                   Jos Wennmacker');
  writeln('                   Universitair Rekencentrum');
  writeln('                   Geert Grooteplein Zuid 41');
  writeln('                   NL-6525 GA Nijmegen');
  writeln('                   The Netherlands');
  writeln;
  writeln;
  writeln;
  writeln('Also comments, bugs etc are expected at one of these addresses.');
  writeln;
  writeln('       Press enter to see next page');
  readln;
  clrscr;
  writeln;
  writeln('           REFORMAT: an original JOS disk tool.');
  writeln;
  writeln('                Public Domain Software.');
  writeln;
  writeln;
  writeln('Use: Reformat [d:]');
  writeln;
  writeln('where d: is an optional driveletter. Ommiting d: will select the');
  writeln('default  drive.  This  program  works for  both fixed  disks and');
  writeln('floppies.');
  writeln;
  writeln('*  WARNING * WARNING * WARNING * WARNING * WARNING * WARNING  **');
  writeln;
  writeln('NEVER use  this  program  on a disk that  contains * PROTECTED *');
  writeln('software. You might find these  programs turned into an  illegal');
  writeln('copy or even end up with a scrambled disk!!!!!!');
  writeln('Always *UNINSTALL* this kind of software before using REFORMAT!!');
  writeln('The program will  prompt you to confirm  this in case of a fixed');
  writeln('disk.');
  writeln;
end;

begin
  if paramcount <> 0
  then if copy(paramstr(1), 1, 1) = '?'
       then begin
            WriteDoc;
            halt;
       end
       else begin
            if ( paramcount > 1 )
            or ( length(paramstr(1)) > 2 )
            or ( (length(paramstr(1)) = 2 ) and
                 (copy(paramstr(1), 2, 1) <> ':') )
            then begin
                 writeln;
                 writeln('Invalid parameter: REFORMAT [d:] or ?.');
                 halt;
       end; end;
  InitCounters;
  InitScreen;
  GetInformation;
  if ClusterSize < FATsize
  then getmem(DTAddress, SectorSize * FATsize)
  else getmem(DTAddress, SectorSize * ClusterSize);
  getmem(SAVEaddress, SectorSize * ClusterSize);
  getmem(PermutationAddress, TotalDataClusters * 2 + 4);
  getmem(OldFATaddress, TotalDataClusters * 2 + 4);
  getmem(NewFATaddress, TotaldataClusters * 2 + 4);
  ReadBootSector(DTAddress^);
  ReadFat(OldFATaddress^, DTAddress^);
  ReadDirectories(DTAddress^);
  move(OldFATaddress^, NewFATaddress^, TotalDataClusters * 2 + 4);
  CheckDisk(NewFATaddress^, RootDir);
  fillchar(NewFATaddress^, TotalDataClusters * 2 + 4, 0);
  for Count := 0 to TotalDataClusters + 1 do
  PermutationAddress^[Count] := Count;
  move(OldFATaddress^, NewFATaddress^, 4);
  RemakeFAT(OldFATaddress^, NewFATaddress^,
            PermutationAddress^, RootDir, 0, 0);
  LinkFreeClusters(OldFATaddress^, NewFATaddress^);
  CountClustersToMove(PermutationAddress^);
  WriteStatistics;
  if NonContiguousFiles <> 0
  then begin
       if Media = FixedDisk
       then begin
            gotoxy(05, 17);
            write ('Fixed disk: did you uninstall all protected software? ',
                   'Continue (Y/N)?');
            Instr := 'Q';
            while not ( Instr in ['Y', 'y', 'N', 'n'] )
            do GetInput(Instr);
            if Instr in ['N', 'n']
            then begin
                 WriteWarning('Press Enter to return to DOS.');
                 GetInput(Instr);
                 clrscr;
                 halt;
       end; end;
       ResetDisk;
       WriteFAT(NewFATaddress^, DTAddress^);
       WriteDirectories(DTAddress^);
       DoIt(PermutationAddress^, DTAddress^, SAVEaddress^);
       ResetDisk;
       if NeedReboot then
          begin
          repeat
             begin
             WriteLog('Done ! Please reboot system to continue');
             GetInput(Anything);
             end;
          until 1 = 2;
          end
       else
          WriteLog('Done ! Press Enter-Key to return to DOS.');
  end
  else begin
       WriteWarning('All files are contiguous. Nothing to be done!');
       WriteLog('Press Enter-Key to return to DOS.');
  end;
  GetInput(Anything);
  clrscr;
end.